; $Id: count.scm,v 1.3 1999/06/02 15:04:45 davidp Exp $
; 
; A function to count entities of a body, and indicate an error, looking
; somewhat like a sys_error, if any do not match the numbers given. Returns
; #t if all the counts matched, #f if some did not.
;
; You can count any THING for which an "entity:THING" function returns a
; list of those entities, for example, edges, faces, vertices, lumps etc.
; If any additional "entity:THING" functions are defined, those will become
; automatically available to the count facility.
;
; Example:
; acis> (define b (solid:block (position 0 0 0) (position 10 10 10)))
; b
; acis> (count b faces 6 edges 10)
;           Number of faces is 6
; *** Error Number of edges is 12
; #f
;
; To use this facility in a test file, use (require 'count "count.scm")
;
; Author: DAP

(provide 'count)

; Firstly a simple destructuring-bind facility to make things more readable.

(define (destructure-bindings vars val)
  (if (pair? vars)
      (append (destructure-bindings (car vars) `(car ,val))
	      (destructure-bindings (cdr vars) `(cdr ,val)))
      (if (not (null? vars)) `((,vars ,val)))))

(define-macro (destructuring-bind vars val . body)
  `(let ((tmp-symbol ,val))
     (let ,(destructure-bindings vars 'tmp-symbol)
       ,@body)))

; Divide the list of type and value pairs e.g. (faces 6 edges 10) into
; 3 lists containing the types e.g. (faces edges), the functions to
; count them e.g. (entity:faces entity:edges), and the values they are
; to be tested against e.g. (6 10)

(define (divide-list lst)
  (if (or (null? lst) (not (pair? (cdr lst))))
      (begin (if (not (null? lst)) (format #t "Ignoring unpaired final type ~a\n" (car lst)))
	     (list '() '() '()))
      (destructuring-bind (type val . rest) lst
	  (let ((function (string->symbol (string-append "entity:" (symbol->string type)))))
	    (if (bound? function)
		(destructuring-bind (types functions vals) (divide-list rest)
		    (list (cons type types)
			  (cons function functions)
			  (cons val vals)))
		(begin (format #t "Ignoring ~a - no function to count it\n" type)
		       (divide-list rest)))))))

; Now it's easy to implement the count facility as described:

(define-macro (count entity . types-and-values)
  (destructuring-bind (types functions vals) (divide-list types-and-values)
      `(count-internal ,entity ',types (list ,@functions) (list ,@vals))))

(define (count-internal entity types functions vals)
  (let ((all-ok #t))
    (map (lambda (t f v) (if (not (count-internal1 entity t f v)) (set! all-ok #f)))
	 types functions vals)
    all-ok))
  
(define (count-internal1 entity type function val)
  (let ((result (apply function entity '())))
    (if (list? result)
	(let ((len (length result)))
	  (if (= len val)
	      (begin (format #t "          Number of ~a is ~a\n" type len) #t)
	      (begin (format #t "*** Error Number of ~a is ~a\n" type len) #f)))
	(begin (format #t "*** Error ~a not countable\n" type) #f))))
